home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / LIBRARY / MCQUAY1 / TDB601.PAS < prev    next >
Pascal/Delphi Source File  |  1993-10-14  |  37KB  |  1,284 lines

  1. (******************************************
  2.  Turbo Pascal / dBase III,III+,IV Interface
  3.  TPDB
  4.  McQuay Technologies
  5.  Copyright 1988,89,90,91,92
  6.  Version 6.01
  7.  1/1/92
  8.  ***************************************)
  9. {$R-,S-,I-,F-,V-,B-,N-}
  10. unit tdb601;
  11. interface
  12. uses dos,fileio6,frte,utils;
  13.  
  14.   const
  15.      db_errorcode : word = 0;
  16.      db_doserrorcode : word = 0;
  17.      dbe_errorcode : word = 0;
  18.      DB_TOP = 1;
  19.      dbEnhance : boolean = false;
  20.          MaxFields = 135;              {128 + 7 forcefields}
  21.          DB_errortrap : boolean = true;
  22.  
  23. {-------------------------------------------------------------------------}
  24.     type
  25.         TPathName = string[64];
  26.         TFieldName = array[1..11] of char;
  27.         TFieldDescript = record
  28.                         FieldName: TFieldName; {   dBase's field name             }
  29.                         FieldType:char;           {   dBase filed type C = char      }
  30.                                                                             {     N = numeric, L = Logical,    }
  31.                                                                             {     D = Date, M = Memo           }
  32.                         FieldLength:byte;         {   Length of field                }
  33.                         Decimals:byte;            {   Number of decimal places       }
  34.                         Inset:word;            {   Offset of field into record    }
  35.                  end;
  36.         TFields = array[1..MaxFields] of TFieldDescript;
  37.         PFields = ^TFields;
  38.  
  39.  
  40.         {.............................}
  41.         TdbStructure =
  42.             record
  43.                 FileName:TPathName;   { Filename of database file (path)     }
  44.                 TurboFile : ^file;
  45.                 Status:Tfilestatus;         { Status of file - open or unknown no  }
  46.                                                                      {   Turbo dBase routine sets this to   }
  47.                                                                      {   closed.  A structure returned with }
  48.                                                                      {   a Query is unknown, otherwise fopen.}
  49.                 version:byte;              {   dBase version file was created with. }
  50.         date: record
  51.           year,month,day:byte;     { Date file was last edited.  Turbo    }
  52.           end;                     {   dBase routines DO NOT update this. }
  53.         RecNum:longint;            { Number of records in file            }
  54.         DataOffset:word;           { First data record's offset into file.}
  55.         RecordLength:integer;      { Record Length                        }
  56.         NumberOfFields:byte;       { Number of fields in each record.     }
  57.                 FieldDescrip:TFields;
  58.         dBEOffset : integer; { McQuay Turbo dBase Enhancer Pointer  }
  59.         dBE : boolean;             { McQuay Turbo dBase Enhancer Flag     }
  60.         dbEPtr : pointer;
  61.         dbESize : word;
  62.       end;
  63.  
  64.  
  65.         PdbStructure = ^TdbStructure;  { A pointer to a dbStructure       }
  66.         TdbRecord = array[0..2048] of char;
  67.  
  68.    function db_ptr(var F : file):pointer;
  69.    function db_error  (var errorcode:integer):boolean;
  70.      procedure db_use (dbFileName:TPathName;
  71.                                 var FileType;
  72.                                                                 var db_Ptr:PdbStructure);
  73.    procedure db_close (var dbfile);
  74.    procedure db_File_Query  (dBFileName:String;
  75.                                                              Var db_Ptr:PdbStructure);
  76.      procedure db_goto(var dbFile; Rec : longint);
  77.      procedure db_read  (var dbfile; var Target);
  78.      procedure db_write  (var dbfile; var Source);
  79.    procedure db_append (var dbfile; var Source);
  80.      procedure db_update_RecNum(var dbfile; Records:longint);
  81.      procedure db_copyfile_structure(OlddbFileName,NewdbFileName:string);
  82.      procedure db_create(dbFileName : string; db : PdbStructure);
  83.      procedure db_dispose_dbptr(var dbptr : PdbStructure);
  84.      procedure dbe_read(var F;var dbeptr:pointer);
  85.      procedure dbe_write(var F;var dbeptr:pointer);
  86.      function db_real(dbAscii:string):real;
  87.      function db_int(dbAscii:string):integer;
  88.      function db_word(dbAscii:string):word;
  89.      function db_longint(dbAscii:string):longint;
  90.      function db_FieldNum(Name:string;var dbf:TdbStructure):word;
  91.    procedure db_date(var dbascii;var day,month,year:word;var error:word);
  92.      function force_dbField(var dbf:TdbStructure;
  93.                           Name:string;FieldType:char;FieldLength:word;
  94.                           FieldInset:word):word;
  95. type
  96.    { Some dBase like field types
  97.      These are not required to use the interface
  98.      But you can use them with your own unltra fast
  99.      routines. }
  100.  
  101.    db_n1 = char;
  102.    db_n2 = array[1..2] of char;
  103.    db_n3 = array[1..3] of char;
  104.    db_n4 = array[1..4] of char;
  105.    db_n5 = array[1..5] of char;
  106.    db_n6 = array[1..6] of char;
  107.    db_n7 = array[1..7] of char;
  108.    db_n8 = array[1..8] of char;
  109.    db_n9 = array[1..9] of char;
  110.    db_n10 = array[1..10] of char;
  111.    db_r3 = db_n3;
  112.    db_r4 = db_n4;
  113.    db_r5 = db_n5;
  114.    db_r6 = db_n6;
  115.    db_r7 = db_n7;
  116.    db_r8 = db_n8;
  117.    db_r9 = db_n9;
  118.    db_r10 = db_n10;
  119.    db_r11 = array[1..11] of char;
  120.    db_r12 = array[1..12] of char;
  121.    db_r13 = array[1..13] of char;
  122.    db_r14 = array[1..14] of char;
  123.    db_r15 = array[1..15] of char;
  124.    db_c1 = char;
  125.    db_c2 = array[1..2] of char;
  126.    db_c3 = array[1..3] of char;
  127.    db_c4 = array[1..4] of char;
  128.    db_c5 = array[1..5] of char;
  129.    db_c6 = array[1..6] of char;
  130.    db_c7 = array[1..7] of char;
  131.    db_c8 = array[1..8] of char;
  132.    db_c9 = array[1..9] of char;
  133.    db_c10 = array[1..10] of char;
  134.    db_c15 = array[1..15] of char;
  135.    db_c20 = array[1..20] of char;
  136.    db_c25 = array[1..25] of char;
  137.    db_c30 = array[1..30] of char;
  138.    db_c35 = array[1..35] of char;
  139.    db_c40 = array[1..40] of char;
  140.    db_c45 = array[1..80] of char;
  141.    db_datefield = array[1..8] of byte;
  142.    db_memofield = array[1..10] of byte;
  143. implementation
  144.  
  145. {TURBO DBASE INTERFACE ROUTINES }
  146.  
  147.   {---------------------------------------------------------------------------}
  148.  
  149. {   McQuay Turbo-dBase Interface Routines
  150.     Version 1.2
  151.     copyright McQuay Technologies 1986
  152.     7/23/86
  153.     r. quay
  154.  
  155.     These routines provide the basic structure needed to access dBase II, III,
  156.     and III+ data files.  All of the major routines will work on either a
  157.     dBase II or dBase III file, with out prior knowledge of the version being
  158.     accessed.
  159.  
  160. {------------------------------------------------------------}
  161. const
  162.   dbptrid : word = $6264;
  163.   dbEID : word = $dbe;
  164. type
  165.   date_header_type = record
  166.        year,month,day:byte;
  167.      end;
  168.  
  169.   {.............................}
  170.   dbFileHeaderType =  record
  171.       id:byte;
  172.       date: date_header_type;
  173.       RecNum:longint;
  174.       dbOffset:word;
  175.       RecordLength:word;
  176.       gap:array[1..20] of byte;
  177.       end;
  178.  
  179.   {.............................}
  180.   dbFieldType = record
  181.          Fname : TFieldName;
  182.      ftype : char;
  183.      somefieldoffset:word;
  184.      memaddr : word;
  185.      flength:byte;
  186.      dlength:byte;
  187.      gap2: array[1..14] of byte;
  188.      end;
  189. {------------------------------------------------------------------}
  190. function farparent :pointer;
  191. inline (
  192.          $8B/$46/$02/  { mov ax,[bp+2] }
  193.          $8B/$56/$04); { mov dx,[bp+4] }
  194.  
  195. function nearparent :pointer;
  196. inline (
  197.          $8C/$CA/      { mov dx,cs        }
  198.          $8B/$46/$02); { mov ax,[bp+2]    }
  199. {------------------------------------------------------------------}
  200. procedure db_RunError(dberr,doserr,dbeerr: word;
  201.                      addr: pointer;
  202.                      message: string);
  203. begin
  204.   db_errorcode := dberr;
  205.   db_doserrorcode := doserr;
  206.   dbe_errorcode := dbeerr;
  207.   if db_ErrorTrap then
  208.     begin
  209.     if message <> '' then
  210.       writeln(message,'  Error codes ',
  211.               db_errorcode:6,db_doserrorcode:6,dbe_errorcode:6);
  212.     FRTError(addr,db_errorcode);
  213.     end;
  214. end;
  215. procedure set_dberror(dberr,doserr,dbeerr:word);
  216. begin
  217.   db_errorcode := dberr;
  218.   db_doserrorcode := doserr;
  219.   dbe_errorcode := dbeerr;
  220. end;
  221. {------------------------------------------------------------}
  222.   function db_error  (var errorcode:integer):boolean;
  223.  
  224. {  This function can be called to check if an error has been generated
  225.    by a Turbo dBase routine.  Will return false if no error.  Will return
  226.    a true if an error has occured.  errorcode will be the error type as
  227.    follows:   1     = File Not Found
  228.               2 & 3 = Error while readig File Header (Not a dBase file)
  229.               4     = Error in Field Descriptor
  230.               5     = Read past end of file
  231.              11     = Try to Add Duplicate Field Name
  232.    Will reset db_error and errorcode to False and 0 respectively.
  233.  
  234.    dbE error code
  235.       1 Error during read of Enhanced field
  236. }
  237. begin
  238.   if db_errorcode > 0 then db_error := True
  239.   else db_error := False;
  240.   errorcode := db_errorcode;
  241.   db_errorcode := 0;
  242. end;
  243.  
  244.  
  245. {------------------------------------------------------------}
  246. procedure decode_db_FieldType(dbfB:dbFieldType;var dbFD:TFieldDescript);
  247. begin
  248.    with dbFD do
  249.      with dbFB do
  250.        begin
  251.        FieldName := FName;
  252.        Fieldtype := FType;
  253.        FieldLength := FLength;
  254.        Decimals := DLength;
  255.        end;
  256. end;
  257. {----------------------------------------------------------------------}
  258. procedure decode_db_Header(dbhead:dbFileHeaderType;
  259.                             var Adbfile;
  260.                                                         var dbPtr:PdbStructure);
  261. var
  262.   tempid:byte;
  263.   dbfile:file absolute AdbFile;
  264.     ioerror,TempWord : word;
  265.   tempoffset : longint;
  266.   tempmark,i,bytes,offset:word;
  267.   field:dbFieldType;
  268. begin
  269.   tempid := dbhead.id and $f;
  270.   tempMark := 0;
  271.   with dbptr^ do
  272.        begin
  273.        version:=3;
  274.        date.year := dbhead.date.year;
  275.        date.month := dbhead.date.month;
  276.        date.day := dbhead.date.day;
  277.        DataOffset := dbhead.dbOffset;
  278.        RecNum := dbhead.RecNum;
  279.        RecordLength := dbhead.Recordlength;
  280.        { Check if Enhanced File }
  281.        dbE := False;
  282.        dbEPtr := nil;
  283.        dbEsize := 0;
  284.        dbEOffset := 0;
  285.        move(dbhead.gap[1],tempmark,2);
  286.        if tempmark = dbEID then
  287.          begin
  288.                  move(dbhead.gap[3],tempword,2);
  289.                  TempOffset := Tempword;
  290.                  ioerror := absoluteseek(dbfile,tempoffset,tempoffset);
  291.          bytes := 2;
  292.                  ioerror := absoluteread(dbfile,tempmark,bytes,bytes);
  293.                  if ioerror >0 then
  294.                      begin
  295.                      set_dberror(0,ioerror,1);
  296.                      exit;
  297.                      end;
  298.                  if tempmark = dbEID then
  299.                      begin
  300.                      dBE := True;
  301.                      dbEoffset := Tempoffset +2;
  302.                      dbESize := DataOffset - dbEoffset;
  303.                      end;
  304.                  end;
  305.              { Point to Fields }
  306.  
  307.             ioerror := absoluteseek(dbfile,$20,Tempoffset);
  308.                  if ioerror >0 then
  309.                      begin
  310.                      set_dberror(1,ioerror,0);
  311.                      exit;
  312.                      end;
  313.             { Read Fields }
  314.             i:=0;
  315.             bytes := $20;
  316.             offset :=1;
  317.             repeat
  318.              i:=i+1;
  319.  
  320.              ioerror := absoluteread(dbfile,field,bytes,bytes);
  321.              if ioerror>0 then
  322.                  if (ioerror<>$26)or(field.Fname[1]<>#13) then
  323.                      begin
  324.                      set_dberror (2,ioerror,0);
  325.                      exit;
  326.            end;
  327.  
  328.        decode_db_fieldType(field,FieldDescrip[i]);
  329.        FieldDescrip[i].inset := offset;
  330.        offset := offset + FieldDescrip[i].FieldLength;
  331.      until field.Fname[1]=chr($D);
  332.      NumberOfFields := i -1;
  333.  
  334.      { assign FIB }
  335.      TurboFile := @dbfile;
  336.    end;
  337. end;
  338. {------------------------------------------------------------}
  339. function db_ptr(var F : file):pointer;
  340. { This routine returns the pointer to the dbStructure for the turbo file F.
  341.   If F has not been opened with db_use, then the pointer is nil.  This
  342.   routine is used mostly as an internal routine for the dbTurbo routines.
  343.   It can also be used as a quick check to see if a file has been opened with
  344.   db_use, check for a nil.}
  345. var
  346.   dbF : filerec absolute F;
  347.   P : pointer;
  348. begin
  349.   if (dbF.UserData[1]=$64)and(dbF.UserData[2]=$62) then
  350.      begin
  351.      move(dbF.UserData[3],P,4);
  352.      db_ptr := P;
  353.      end
  354.   else
  355.     db_ptr := nil;
  356. end;
  357.  
  358. {------------------------------------------------------------}
  359. procedure install_db_ptr(var F:file;P:pointer);
  360. { This is an internal dbTurbo routine.  It is used by db_Use to install
  361.   a pointer to the files dbStructure in Turbo's FIB for your convenience. }
  362. var
  363.   dbF : filerec absolute F;
  364. begin
  365.   dbF.UserData[1] := $64;
  366.   dbF.UserData[2] := $62;
  367.   move(P,dbF.UserData[3],4);
  368. end;
  369.  
  370. { This routine is used by db_close, to remove the above mentioned pointer. }
  371. procedure uninstall_db_ptr(var F:file);
  372. var
  373.   dbF : filerec absolute F;
  374. begin
  375.   fillchar(dbF.UserData[1],6,0);
  376. end;
  377.  
  378. {------------------------------------------------------}
  379. procedure dbe_read(var F;var dbeptr:pointer);
  380. var
  381.   afile : file absolute F;
  382.     dbptr : PdbStructure;
  383.     bytes,ioerror : word;
  384.     Fpos:longint;
  385. begin
  386.   dbptr := db_ptr(aFile);
  387.   if dbptr = nil then
  388.     begin
  389.     db_RUNerror (0,0,2,farparent,'File Not Opened with DB_USE');
  390.     exit;
  391.     end
  392.   else
  393.     if not dbptr^.dbE then
  394.       begin
  395.       db_RUNerror (0,0,3,farparent,'dBase File Not Enhanced');
  396.       exit;
  397.       end
  398.     else
  399.       with dbptr^ do
  400.         begin
  401.                 ioerror := absoluteseek(afile,dbEoffset,Fpos);
  402.                  if ioerror >0 then
  403.            begin
  404.            db_RUNerror (0,ioerror,4,farparent,'File Read Error');
  405.            exit;
  406.            end;
  407.         if dbEptr = nil then
  408.          if maxavail<dbEsize then
  409.            begin
  410.            db_RUNerror (0,ioerror,5,farparent,
  411.                           'Not enough memory for DBE buffer');
  412.            exit;
  413.            end
  414.          else
  415.            getmem(dbEptr,dbEsize);
  416.         bytes := dbEsize;
  417.                 ioerror := absoluteread(afile,dbEptr^,bytes,bytes);
  418.                 if ioerror>0 then
  419.                      begin
  420.                      db_RUNerror (0,ioerror,6,farparent,'File Read Error');
  421.                      exit;
  422.                      end;
  423.                 end;
  424. end;
  425. {--------------------------------------------------------}
  426. procedure dbe_write(var F;var dbeptr:pointer);
  427. var
  428.   afile : file absolute F;
  429.     Fpos:longint;
  430.     dbptr : PdbStructure;
  431.   bytes,ioerror : word;
  432.   tempdtoffset : word;
  433.   endmark : byte;
  434. begin
  435.   dbptr := db_ptr(aFile);
  436.   if dbptr = nil then
  437.     begin
  438.     db_RUNerror (0,0,7,farparent,'File not opened with DB_USE');
  439.     exit;
  440.     end
  441.   else
  442.     if not dbptr^.dbE then
  443.       begin
  444.       db_RUNerror (0,0,8,farparent,'File not enhanced');
  445.       exit;
  446.       end
  447.     else
  448.       if dbptr^.dbEptr=nil then
  449.         begin
  450.         db_RUNerror (0,0,9,farparent,'Enhanced Pointer is nil');
  451.         exit;
  452.         end
  453.       else
  454.         with dbptr^ do
  455.           begin
  456.                     ioerror := absoluteseek(afile,dbEoffset-2,Fpos);
  457.                     if ioerror>0 then
  458.                         begin
  459.                         db_RUNerror (0,ioerror,10,farparent,'File Seek Error');
  460.                         exit;
  461.                         end;
  462.                     bytes := 2;
  463.                     ioerror := absolutewrite(afile,dbeID,bytes,bytes);
  464.                     bytes := dbEsize;
  465.                     ioerror := absolutewrite(afile,dbEptr^,bytes,bytes);
  466.             endMark := $D;
  467.             ioerror := absolutewrite(afile,endMark,1,bytes);
  468.                     end;
  469.                 if ioerror>0 then
  470.           begin
  471.           db_RUNerror (0,ioerror,11,farparent,'File Write Error');
  472.           exit;
  473.           end;
  474. end;
  475.  
  476. {------------------------------------------------------------}
  477. procedure db_dispose_dbptr(var dbptr : PdbStructure);
  478. var
  479.     db:PdbStructure absolute dbptr;
  480. begin
  481.   with db^ do
  482.     begin
  483.     if dbE and (dbEptr <> nil) then
  484.       freemem(dbEptr,dbEsize);
  485.         if seg(db^)>Dseg then
  486.          freemem(db,sizeof(db^))
  487.         else
  488.             fillchar(db^,sizeof(db^),0);
  489.         end;
  490. end;
  491.  
  492. {------------------------------------------------------------}
  493.     procedure db_use (dbFileName:TPathName;
  494.                                                                 var FileType;
  495.                                                                 var db_Ptr:PdbStructure);
  496.  
  497. {  This proc fopens a dbase file for use by all Turbo dBase Routines.  It
  498.      assigns the file, resets the file, reads the file header, creates a
  499.    dbStructure, and sets the file pointer to the first record.
  500.    If FileType has already been assigned, then this proc begins with a
  501.    reset.  If FileType has already been reset, then it begins by reading
  502.    the file header.  Regardless, on exit the record pointer for FileType
  503.    points to the first data record.  If FileType has not been used in a
  504.      Turbo Pascal ASSIGN and RESET procedure, then only Turbo dBase routines or
  505.    McQuay Extended FileIO routines should be used to read and write to
  506.    this file.  However, if FileType has been used in a Turbo Pascal ASSIGN
  507.    and RESET statement before being passed to this proc, then any of Turbo
  508.    Pascals file IO routines, as well as Turbo dBase and McQuay Extended File IO
  509.    routines, can be used with this file (including BlockRead and BlockWrite!).
  510.      Now that opens a lot of possibilities!
  511.    Use dBerror to check for IO errors.  If an error does occur, FileType
  512.    is closed regardless of who assigned it.
  513. }
  514.  
  515.  var
  516.     dbfile : file absolute FileType;
  517.     dbptr : PdbStructure absolute db_ptr;
  518.     dbhead : dbFileHeaderType;
  519.     ioerror,bytes:word;
  520.     FPos : longint;
  521.     TempFIB : FileRec;
  522.     err : word;
  523.     errptr :pointer;
  524.     FileStatus:TFileStatus;
  525. begin
  526.     db_errorcode :=0;
  527.     ioerror := 0;
  528.     fillchar(dbhead,sizeof(dbhead),0);
  529.     FileStatus := TurboFileStatus(dbFile);
  530.     if FIleStatus = unknown then
  531.         begin
  532.     assign(dbfile,dbfilename);
  533.         reset(dbfile);
  534.     end;
  535.     if FileStatus = Closed then
  536.         reset(dbfile);
  537.     err := ioresult;
  538.     if err >0 then
  539.         begin
  540.     db_RUNerror (12,err,0,farparent,'File Reset Failure');
  541.     db_close(dbfile);
  542.     db_dispose_dBPtr(db_Ptr);
  543.     exit;
  544.     end;
  545.  
  546.   bytes := 0;
  547.     ioerror := AbsoluteSeek(FileType,bytes,Fpos);
  548.     { read dbase file header }
  549.     bytes := sizeof(dbhead);
  550.     ioerror := AbsoluteRead(dbfile,dbhead,bytes,bytes);
  551.     err := ioerror;
  552.     if err >0 then
  553.         begin
  554.         db_RUNerror (13,err,0,farparent,'File Read Error');
  555.     db_close(dbfile);
  556.     db_dispose_dBPtr(db_Ptr);
  557.     exit;
  558.     end;
  559.  
  560.   { get new pointer  }
  561.   if dbPtr = nil then
  562.     if maxavail<sizeof(dbPtr^) then
  563.       begin
  564.       db_RUNerror (14,0,0,farparent,'Not Enough Memory');
  565.       exit;
  566.       end
  567.     else
  568.       new(dbPtr);
  569.  
  570.   { Put pointer into file structure }
  571.   install_db_ptr(dbfile,dbptr);
  572.  
  573.   { set filename and status }
  574.   dbPtr^.FileName := dbFileName;
  575.     dbPtr^.Status := TurboFileStatus(FileType);
  576.  
  577.   { decode header }
  578.   decode_db_Header(dbhead,dbfile,dbPtr);
  579.   if db_errorcode>0 then
  580.     begin
  581.     db_RUNerror (db_errorcode,db_doserrorcode,dbE_errorcode,farparent,
  582.     'Bad File Header');
  583.     exit;
  584.     end;
  585.  
  586.   { If this is an enhanced file, and dbEnhance flag on, get
  587.     enhanced data }
  588.   if dbEnhance and dbPtr^.dbE then
  589.     with dbptr^ do
  590.       dbe_read(FileType,dbeptr);
  591.   if db_errorcode>0 then
  592.     begin
  593.     db_RUNerror (db_errorcode,db_doserrorcode,dbE_errorcode,
  594.                  farparent,'File Read Error');
  595.     exit;
  596.     end;
  597.  
  598.   { move file pointer to data }
  599.     ioerror := AbsoluteSeek(FileType,dbPtr^.DataOffset,FPos);
  600.     if ioerror >0 then
  601.         begin
  602.         db_RUNerror (18,ioerror,0,farparent,'File Seek Error');
  603.         db_close(dbfile);
  604.         db_dispose_dBPtr(db_Ptr);
  605.         exit;
  606.         end;
  607. end;
  608.  
  609. {------------------------------------------------------------}
  610. procedure db_close (var dbfile);
  611. {  Closes a dBase file }
  612.  
  613. var
  614.   afile : file absolute dbfile;
  615.   textfile : text absolute dbfile;
  616.     dbptr : PdbStructure;
  617.   tpmode : word;
  618. begin
  619.   dbptr := db_ptr(afile);
  620.  
  621.   { If nil then just ignore call with no error }
  622.   if dbptr = nil then
  623.     exit
  624.   else
  625.     begin
  626.     uninstall_db_ptr(afile);
  627.     { check if enhanced and if so uninstall enhanced data structures }
  628.     with dbptr^ do
  629.       if dbenhance and dbE and (dbEptr<>nil) then
  630.         begin
  631.         freemem(dbEptr,dbEsize);
  632.         dbEsize := 0;
  633.         dbEptr := nil;
  634.         end;
  635.     end;
  636.  { check to see what kind of file it is, if it is a textfile use a textfile
  637.     close, otherewise use a file close.  If already closed the just clean
  638.     up and exit.
  639.  }
  640.   case (turboFilemode(dbfile) and $ff) of
  641.     $B1,$B2 : close(textfile);
  642.     $B3 : close(afile);
  643.     end;
  644.  
  645. end;
  646.  
  647. {------------------------------------------------------------}
  648. procedure db_File_Query  (dBFileName:String;  Var db_Ptr:PdbStructure);
  649.  
  650. {  This proc can be used to examine the structure of a dBase file with
  651.    out opening it for use.  It simply opens the file, reads its header
  652.    and puts it into a dbstructure.  Is used by the db_copyfile_structure()
  653.    routine.
  654. }
  655.  var
  656.   dbfile : file of dbFileHeaderType;
  657.   dbhead : dbFileHeaderType;
  658.     dbptr : PdbStructure absolute db_ptr;
  659.     ioerror,bytes : word;
  660.     Fpos:longint;
  661. begin
  662.   fillchar(dbhead,sizeof(dbhead),0);
  663.   assign(dbfile,dbFileName);
  664.   reset(dbfile);
  665.   if ioresult >0 then
  666.     begin
  667.     db_RUNerror (0,0,19,farparent,'File Reset Error');
  668.     exit;
  669.     end;
  670.  
  671.   { read dbase file header }
  672.   Read(dbfile,dbhead);
  673.   if ioresult >0 then
  674.     begin
  675.     db_RUNerror (20,0,0,farparent,'File Read Error');
  676.     exit;
  677.     end;
  678.  
  679.   { get new pointer  }
  680.   if dbPtr = nil then
  681.     new(dbPtr);
  682.  
  683.   { set filename and status }
  684.   dbPtr^.FileName := dbFileName;
  685.   dbPtr^.Status := unknown;
  686.  
  687.   { decode header }
  688.   decode_db_Header(dbhead,dbfile,dbPtr);
  689.  
  690.   { check if enhanced }
  691.   if dbPtr^.dbE and dbEnhance then
  692.     with dbptr^ do
  693.       begin
  694.       getmem(dbEptr,dbEsize);
  695.             ioerror := absoluteseek(dbFile,dbEOffset,FPos);
  696.             bytes := dbESIze;
  697.             ioerror := absoluteread(dbFile,dbEPtr^,bytes,bytes);
  698.             if ioerror >0 then
  699.                 begin
  700.                 db_RUNerror (0,0,20,farparent,'File Read Error');
  701.                 exit;
  702.                 end;
  703.             end;
  704.     db_close(dbfile);
  705. end;
  706.  
  707.  
  708. {------------------------------------------------------------}
  709. procedure db_goto(var dbFile; Rec : longint);
  710. var
  711.   Afile : file absolute dbfile;
  712.   bytes :longint;
  713.   ioerror: word;
  714.     dbptr : PdbStructure;
  715.   fp : longint;
  716. begin
  717.   if Rec=0 then
  718.     begin
  719.     db_RUNerror (21,0,0,farparent,'Record equals 0');
  720.     exit;
  721.     end;
  722.   dbptr := db_ptr(afile);
  723.   if dbptr = nil then
  724.     begin
  725.     db_RUNerror (22,0,0,farparent,'Pointer is nil');
  726.     exit;
  727.     end;
  728.   bytes := (dbPtr^.RecordLength * (Rec-1)) + dbPtr^.DataOffset;
  729.     ioerror := absoluteseek(afile,bytes,bytes);
  730.     if ioerror > 0 then
  731.         begin
  732.         db_RUNerror (23,0,0,farparent,'File Seek Error');
  733.         exit;
  734.         end;
  735. end;
  736. {------------------------------------------------------------}
  737. procedure db_read  (var dbfile; var Target);
  738.  
  739.  
  740. { This procedure can be used to read a record from a dBase file.  All fields
  741.   of the record for the current location of the file pointer is transfered
  742.   to Target.  The routine does not (can not) check that Target is as large
  743.   as the record length.  Passing a variable to Target that is smaller than
  744.   the record length will have unpredictable results.  This function unlike
  745.   Turbo's READ leaves the file pointer pointing at the record it just read
  746.   rather than at the next record.
  747. }
  748. var
  749.   Afile : file absolute dbfile;
  750.   bytes,ioerror: word;
  751.     dbptr : PdbStructure;
  752.   fp : longint;
  753. begin
  754.   if db_errorcode>0 then exit;
  755.   dbptr := db_ptr(afile);
  756.   if dbptr = nil then
  757.     begin
  758.     db_RUNerror (24,0,0,farparent,'Pointer is nil');
  759.     exit;
  760.     end;
  761.   bytes := dbPtr^.RecordLength;
  762.   fp := absolutefilepos(afile,ioerror);
  763.   if ioerror > 0 then
  764.     begin
  765.     db_RUNerror(25,0,0,farparent,'File Seek Error');
  766.     exit;
  767.     end;
  768.     ioerror := AbsoluteRead(Afile,Target,Bytes,bytes);
  769.   if ioerror > 0 then
  770.     begin
  771.     db_RUNerror(26,0,0,farparent,'File Read Error');
  772.     exit;
  773.     end;
  774.     ioerror := absoluteseek(Afile,fp,fp);
  775.   if ioerror > 0 then
  776.     begin
  777.     db_RUNerror(27,0,0,farparent,'File Seek Error');
  778.     exit;
  779.     end;
  780. end;
  781. {------------------------------------------------------------}
  782. procedure db_write  (var dbfile; var Source);
  783.  
  784.  
  785. { This procedure can be used to write a record to a dBase file.  All fields
  786.   of the record for the current location of the file pointer is transferred
  787.   to Target.  The routine does not (can not) check that Source is as large
  788.   as the record length.  Passing a Source that is smaller than
  789.   the record length will have unpredictable results (i.e. write junk
  790.   to the file).  This function unlike Turbo's WRITE leaves the file pointer
  791.   pointing at the record it just read rather than at the next record.
  792. }
  793. var
  794.   Afile : file absolute dbfile;
  795.   bytes,ioerror: word;
  796.     dbptr : PdbStructure;
  797.   fp : longint;
  798. begin
  799.   if db_errorcode>0 then exit;
  800.   dbptr := db_ptr(afile);
  801.   if dbptr = nil then exit;
  802.   bytes := dbPtr^.RecordLength;
  803.   fp := absolutefilepos(afile,ioerror);
  804.   if ioerror > 0 then
  805.     begin
  806.     db_RUNerror(28,0,0,farparent,'File Seek Error');
  807.     exit;
  808.     end;
  809.     ioerror := Absolutewrite(Afile,Source,Bytes,bytes);
  810.     if ioerror > 0 then
  811.         begin
  812.         db_RUNerror(29,0,0,farparent,'File Write Error');
  813.         exit;
  814.         end;
  815.     ioerror := absoluteseek(Afile,fp,fp);
  816.     if ioerror > 0 then
  817.         begin
  818.         db_RUNerror(30,0,0,farparent,'File Seek Error');
  819.         exit;
  820.         end;
  821. end;
  822. {------------------------------------------------------------}
  823.   procedure db_append (var dbfile; var Source);
  824.    var
  825.      Afile : file absolute dbfile;
  826.      bytes,ioerror: word;
  827.        dbptr : PdbStructure;
  828.      fp : longint;
  829.    begin
  830.    if db_errorcode>0 then exit;
  831.    dbptr := db_ptr(afile);
  832.    if dbptr = nil then exit;
  833.    db_goto(dbfile,dbptr^.Recnum+1);
  834.    db_write(dbfile,Source);
  835.    db_update_RecNum(dbfile,dbptr^.Recnum+1);
  836.    end;
  837.  
  838. {------------------------------------------------------------}
  839. procedure encode_db_FieldType(var dbfB:dbFieldType;dbFD:TFieldDescript);
  840. procedure place_null(F1:TFieldName;var F2:TFieldName);
  841. var
  842.   i:word;
  843. begin
  844.   i:=1;
  845.   F2 := F1;
  846.   while (f1[i]<>' ')and(i<11) do inc(i);
  847.   F2[i] := char(0);
  848. end;
  849. begin
  850.    with dbFD do
  851.      with dbFB do
  852.        begin
  853.        place_null(FieldName,FName);
  854.        Ftype := Fieldtype;
  855.        Flength := FieldLength;
  856.        Dlength := Decimals;
  857.        fillchar(gap2,sizeof(gap2),0);
  858.        end;
  859. end;
  860. {------------------------------------------------------------}
  861. procedure write_db_Header(var Adbfile;
  862.                                                     var dbptr:TdbStructure);
  863. var
  864.   dbfile:file absolute AdbFile;
  865.   dbhead:dbFileHeaderType;
  866.   ioerror : word;
  867.     tempoffset,fp : longint;
  868.   tempmark : byte;
  869.   i,bytes,offset,y,m,d:word;
  870.   field:dbFieldType;
  871. begin
  872.   dbhead.id :=3;
  873.   tempMark := 0;
  874.   with dbptr do
  875.        begin
  876.        getdate(y,m,d,i);
  877.        dbhead.date.year := y-1900;
  878.        dbhead.date.month := m;
  879.        dbhead.date.day := d;
  880.        dbhead.dbOffset := DataOffset;
  881.        dbhead.RecNum := Recnum;
  882.        dbhead.Recordlength :=RecordLength;
  883.        fillchar(dbhead.gap,sizeof(dbhead.gap),0);
  884.        if DBE and (dbEptr<>nil) then
  885.          begin
  886.          tempmark := dbEoffset -2;
  887.          move(dbEID,dbhead.gap[1],2);
  888.          move(tempmark,dbhead.gap[3],2);
  889.                if dbptr.dataoffset = ((32*(dbptr.NumberOfFields+1))+1) then
  890.                    begin
  891.            dbptr.dbeoffset := dbptr.dataoffset;
  892.            dbptr.dataoffset := dbptr.dataoffset + dbptr.dbEsize +1;
  893.            dbhead.dbOffset := dbptr.DataOffset;
  894.            end;
  895.          end
  896.        else
  897.          fillchar(dbhead.gap,0,sizeof(dbhead.gap));
  898.        end;
  899.      ioerror := absoluteseek(dbfile,0,fp);
  900.     if ioerror > 0 then
  901.         begin
  902.         db_RUNerror(31,0,0,farparent,'File Seek Error');
  903.         exit;
  904.         end;
  905.     bytes := sizeof(dbhead);
  906.     ioerror := absolutewrite(dbfile,dbhead,bytes,bytes);
  907.     if ioerror > 0 then
  908.         begin
  909.         db_RUNerror(31,0,0,farparent,'File Write Error');
  910.         exit;
  911.         end;
  912.      for i:=1 to Dbptr.NumberOfFields do
  913.      begin
  914.      encode_db_fieldtype(field,dbptr.fielddescrip[i]);
  915.          ioerror := absolutewrite(dbfile,field,$20,bytes);
  916.          end;
  917.      tempMark := $D;
  918.      ioerror := absolutewrite(dbfile,tempMark,1,bytes);
  919.      if (dbptr.dbE) and (dbptr.dbEptr<>nil) then
  920.             begin
  921.             dbe_write(dbfile,dbptr.dbEptr);
  922.             end;
  923.     if ioerror > 0 then
  924.         begin
  925.     db_RUNerror(32,0,0,farparent,'File Write Error');
  926.     exit;
  927.     end;
  928. end;
  929.  
  930.  
  931. {------------------------------------------------------------}
  932. procedure db_update_RecNum(var dbFile; Records: longint);
  933. var
  934.   Afile : file absolute dbfile;
  935.   bytes,ioerror: word;
  936.     dbptr : PdbStructure;
  937.   fp : longint;
  938. begin
  939.   if db_errorcode>0 then exit;
  940.   dbptr := db_ptr(afile);
  941.   if dbptr = nil then
  942.     begin
  943.     db_RUNerror(34,0,0,farparent,'File not opened with DB_USE');
  944.     exit;
  945.     end;
  946.   fp := absolutefilepos(afile,ioerror);
  947.   dbptr^.recnum := Records;
  948.   write_db_Header(dbfile,dbptr^);
  949.   if db_errorcode > 0 then
  950.     begin
  951.     db_RUNerror(db_errorcode,db_doserrorcode,dbe_errorcode,
  952.                 farparent,'Header Update Error');
  953.     exit;
  954.     end;
  955.     ioerror := absoluteseek(Afile,fp,fp);
  956.     if ioerror > 0 then
  957.         begin
  958.         db_RUNerror(35,0,0,farparent,'File Seek Error');
  959.         exit;
  960.         end;
  961. end;
  962.  
  963. {------------------------------------------------------------}
  964. procedure db_create(dbFileName : string; db : PdbStructure);
  965. { This routine will create an empty dbase file.  All that needs to
  966.   be passed in the dbstructure is the number of fields and the
  967.   fielddescrip array }
  968. var
  969.   dbfile:file;
  970.   dbF : filerec absolute dbFile;
  971.   P : pointer;
  972.     dbptr : PdbStructure absolute db;
  973.   ioerror : word;
  974.   tempoffset : longint;
  975.   tempmark : byte;
  976.   i,bytes,offset,y,m,d:word;
  977.   field:dbFieldType;
  978. begin
  979.  
  980.   assign(dbfile,dbFilename);
  981.   rewrite(dbfile);
  982.   ioerror := ioresult;
  983.   if ioerror > 0 then
  984.     begin
  985.     db_RUNerror(33,ioerror,0,farparent,'File Rewrite Failure');
  986.     exit;
  987.     end;
  988.   dbF.UserData[1]:=$64;
  989.   dbF.UserData[2]:=$62;
  990.   move(db,dbF.UserData[3],4);
  991.   with dbptr^ do
  992.     begin
  993.     recnum := 0;
  994.     dataOffset := (32*(NumberOfFields+1))+1;
  995.     RecordLength := 0;
  996.     for i:=1 to NumberOfFields do
  997.       RecordLength := RecordLength +
  998.         FieldDescrip[i].FieldLength;
  999.     inc(RecordLength);
  1000.     write_db_header(dbfile,dbptr^);
  1001.     end;
  1002.   close(dbfile);
  1003.  
  1004. end;
  1005.  
  1006. {------------------------------------------------------------}
  1007. procedure db_copyfile_structure(OlddbFileName,NewdbFileName:string);
  1008. var
  1009.     newdb,olddb:TdbStructure;
  1010.     newdbptr,olddbptr : PdbStructure;
  1011.   oldfile,newfile:file;
  1012.   ioerror : word;
  1013. begin
  1014.   newdbptr := @newdb;
  1015.   db_File_Query(olddbFileName,newdbptr);
  1016.   assign(newfile,NewdbFilename);
  1017.   rewrite(newfile);
  1018.   ioerror := ioresult;
  1019.   if ioerror > 0 then
  1020.     begin
  1021.     db_RUNerror(33,ioerror,0,farparent,'File Rewrite Failure');
  1022.     exit;
  1023.     end;
  1024.   if newdb.dbE then
  1025.     with newdb do
  1026.       if (dbEptr = nil) then
  1027.         begin
  1028.         assign(oldfile,OlddbFilename);
  1029.         olddbPtr := @olddb;
  1030.         getmem(dbEptr,dbEsize);
  1031.         db_use(olddbFilename,oldfile,olddbptr);
  1032.         dbe_read(oldfile,dbEptr);
  1033.         close(oldfile);
  1034.         end;
  1035.   write_db_header(newfile,newdb);
  1036.   close(newfile);
  1037. end;
  1038.  
  1039.  
  1040.  
  1041. {------------------------------------------------------------}
  1042. function db_real(dbAscii:string):real;
  1043.  
  1044. { This function will convert a dBase ASCII field into a Turbo real type
  1045.   value.  Leading spaces are ignored, trailing spaces are fatal.  A field
  1046.   with all spaces is translated as a 0 value.  dBError 101 means that this
  1047.   function wa unable to translate a value.
  1048.   This routine is fairly slow, but requires no "intelligence" about the
  1049.   particular field being translated.
  1050. }
  1051. var
  1052.   tempstr:string;
  1053.   i,j,k,l:integer;
  1054.   tempreal:real;
  1055. begin
  1056.   j:=length(dbAscii);
  1057.   i:=1;
  1058.   while (dbAscii[i]=#32)and(i<j) do
  1059.     i:=i+1;
  1060.   k:=1;
  1061.   while (i<=j) do
  1062.     begin
  1063.     tempstr[k] := dbAscii[i];
  1064.     i:=i +1;
  1065.     k:= k+1;
  1066.     end;
  1067.   tempstr[0] := chr(k-1);
  1068.   val(tempstr,tempreal,k);
  1069.   if (k=0)or(k=j) then
  1070.     db_real := tempreal
  1071.   else
  1072.     begin
  1073.     db_real := 0;
  1074.     db_RUNerror(101,0,0,farparent,'Can not Evaluate Field');
  1075.     end;
  1076. end;
  1077.  
  1078. {------------------------------------------------------------}
  1079. function db_int(dbAscii:string):integer;
  1080.  
  1081. { This function will convert a dBase ASCII field into a Turbo integer type
  1082.   value.  Leading spaces are ignored, trailing spaces are fatal.  A field
  1083.   with all spaces is translated as a 0 value.  dBError 13 means that this
  1084.   function wa unable to translate a value.
  1085. }
  1086. var
  1087.   tempstr:string;
  1088.   i,j,k,l:integer;
  1089.   temp:integer;
  1090. begin
  1091.   j:=length(dbAscii);
  1092.   i:=1;
  1093.   while (dbAscii[i]=#32)and(i<j) do
  1094.     i:=i+1;
  1095.   k:=1;
  1096.   while (i<=j) do
  1097.     begin
  1098.     tempstr[k] := dbAscii[i];
  1099.     i:=i +1;
  1100.     k:= k+1;
  1101.     end;
  1102.   tempstr[0] := chr(k-1);
  1103.   val(tempstr,temp,k);
  1104.   if (k=0)or(k=j) then
  1105.     db_int := temp
  1106.   else
  1107.     begin
  1108.     db_int := 0;
  1109.     db_RUNerror(101,0,0,farparent,'Can not Evaluate Field');
  1110.     end;
  1111. end;
  1112. {------------------------------------------------------------}
  1113. function db_word(dbAscii:string):word;
  1114.  
  1115. { This function will convert a dBase ASCII field into a Turbo word type
  1116.   value.  Leading spaces are ignored, trailing spaces are fatal.  A field
  1117.   with all spaces is translated as a 0 value.  dBError 101 means that this
  1118.   function wa unable to translate a value.
  1119. }
  1120. var
  1121.   tempstr:string;
  1122.   i,j,k,l:integer;
  1123.   temp:word;
  1124. begin
  1125.   j:=length(dbAscii);
  1126.   i:=1;
  1127.   while (dbAscii[i]=#32)and(i<j) do
  1128.     i:=i+1;
  1129.   k:=1;
  1130.   while (i<=j) do
  1131.     begin
  1132.     tempstr[k] := dbAscii[i];
  1133.     i:=i +1;
  1134.     k:= k+1;
  1135.     end;
  1136.   tempstr[0] := chr(k-1);
  1137.   val(tempstr,temp,k);
  1138.   if (k=0)or(k=j) then
  1139.     db_word := temp
  1140.   else
  1141.     begin
  1142.     db_word := 0;
  1143.     db_RUNerror(101,0,0,farparent,'Can not Evaluate Field');
  1144.     end;
  1145. end;
  1146. {------------------------------------------------------------}
  1147. function db_longint(dbAscii:string):longint;
  1148.  
  1149. { This function will convert a dBase ASCII field into a Turbo word type
  1150.   value.  Leading spaces are ignored, trailing spaces are fatal.  A field
  1151.   with all spaces is translated as a 0 value.  dBError 101 means that this
  1152.   function wa unable to translate a value.
  1153. }
  1154. var
  1155.   tempstr:string;
  1156.   i,j,k,l:integer;
  1157.   temp:longint;
  1158. begin
  1159.   j:=length(dbAscii);
  1160.   i:=1;
  1161.   while (dbAscii[i]=#32)and(i<j) do
  1162.     i:=i+1;
  1163.   k:=1;
  1164.   while (i<=j) do
  1165.     begin
  1166.     tempstr[k] := dbAscii[i];
  1167.     i:=i +1;
  1168.     k:= k+1;
  1169.     end;
  1170.   tempstr[0] := chr(k-1);
  1171.   val(tempstr,temp,k);
  1172.   if (k=0)or(k=j) then
  1173.     db_longint := temp
  1174.   else
  1175.     begin
  1176.     db_longint := 0;
  1177.     db_RUNerror(101,0,0,farparent,'Can not Evaluate Field');
  1178.     end;
  1179. end;
  1180. {**************************************************************}
  1181. procedure db_date(var dbascii;var day,month,year:word;var error:word);
  1182. var
  1183.     i,j:word;
  1184.     temp:string;
  1185.     d:array[1..8] of char absolute dbascii;
  1186. begin
  1187.     day := 0;
  1188.     month := 0;
  1189.     year := 0;
  1190.     move(d[1],temp[1],4);
  1191.     temp[0]:=#4;
  1192.     val(temp,i,error);
  1193.     if error>0 then exit;
  1194.     year := i;
  1195.     move(d[5],temp[1],2);
  1196.     temp[0]:=#2;
  1197.     val(temp,i,error);
  1198.     if error>0 then exit;
  1199.     month := i;
  1200.     move(d[7],temp[1],2);
  1201.     temp[0]:=#2;
  1202.     val(temp,i,error);
  1203.     if error>0 then exit;
  1204.     day := i;
  1205. end;
  1206.  
  1207. function db_FieldNum(Name:string;var dbf:TdbStructure):word;
  1208. var
  1209.     i,j,k:word;
  1210.     found:boolean;
  1211.     temp : array[1..11] of char;
  1212. begin
  1213.     k:=length(Name);
  1214.     if k>11 then k:=11;
  1215.     j:=0;
  1216.     for i:=1 to k do
  1217.         if Name[i] in ['#','0'..'z'] then
  1218.             begin
  1219.             inc(j);
  1220.             temp[j]:=upcase(Name[i]);
  1221.             end;
  1222.     k:=j;
  1223.     i:=0;
  1224.     repeat
  1225.         inc(i);
  1226.         found := true;
  1227.         j:=0;
  1228.         repeat
  1229.             inc(j);
  1230.             found :=  (dbf.fieldDescrip[i].fieldname[j] = temp[j]) ;
  1231.         until (not found) or (j=k);
  1232.         if found and ((j=11) or (dbf.fieldDescrip[i].fieldname[j+1]  = #0)) then
  1233.             found := true
  1234.         else
  1235.             found := false;
  1236.  
  1237.     until found or (i=dbf.NumberOfFields);
  1238.     if found then
  1239.     db_FieldNum := i
  1240.   else
  1241.     db_FieldNum := 0;
  1242. end;
  1243.  
  1244.   {****************************************************************}
  1245.     function force_dbField(var dbf:TdbStructure;
  1246.                           Name:string;FieldType:char;FieldLength:word;
  1247.                           FieldInset:word):word;
  1248.   var
  1249.     i:word;
  1250.   begin
  1251.     if db_errorcode>0 then exit;
  1252.     with dbf do
  1253.       begin
  1254.       if numberOfFields = MaxFields then
  1255.         begin
  1256.         db_RUNerror(0,0,14,farparent,'To Many Fields to Force New Field');
  1257.         exit;
  1258.         Force_dbField := 0;
  1259.         end;
  1260.       inc(NumberOfFields);
  1261.       i:=1;
  1262.       while (Name[i] in ['#','0'..'9','A'..'Z','a'..'z'])and(i<12) do
  1263.         begin
  1264.         fielddescrip[NumberOfFields].FieldName[i] := Name[i];
  1265.         inc(i);
  1266.         end;
  1267.       if i=1 then
  1268.         begin
  1269.         db_RUNerror(0,0,14,farparent,'Bad FieldName');
  1270.         exit;
  1271.         end;
  1272.       while i<12 do
  1273.         begin
  1274.         fielddescrip[NumberOfFields].FieldName[i] := #0;
  1275.         inc(i);
  1276.         end;
  1277.       fielddescrip[NumberOfFields].FieldType := FieldType;
  1278.       fielddescrip[NumberOfFields].FieldLength := FieldLength;
  1279.       fielddescrip[NumberOfFields].inset := Fieldinset;
  1280.       fielddescrip[NumberOfFields].Decimals := 0;
  1281.       force_dbField := NumberOfFields;
  1282.       end;
  1283.   end;
  1284. end.